home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / KERNEL3.SEQ < prev    next >
Text File  |  1988-06-22  |  18KB  |  540 lines
  1. \ KERNEL3.SEQ   More kernel stuff
  2.  
  3. FILES DEFINITIONS
  4.  
  5. VARIABLE KERNEL3.SEQ
  6.  
  7. FORTH DEFINITIONS
  8.  
  9. : >TYPE         ( adr len -- )
  10.                 TUCK PAD SWAP CMOVE   PAD SWAP TYPE  ;
  11.  
  12. : .(            ( -- )  ASCII ) PARSE >TYPE  ; IMMEDIATE
  13.  
  14. : (             ( -- )  ASCII ) PARSE 2DROP  ; IMMEDIATE
  15.  
  16. CODE TRAVERSE   ( addr direction -- addr' )
  17.                 POP CX          POP BX
  18.                 ADD BX, CX      PUSH ES
  19.                 MOV ES, YSEG
  20.           BEGIN
  21.                 MOV ES: AL, 0 [BX]      AND AL, # 128
  22.        0= WHILE
  23.                 ADD BX, CX
  24.           REPEAT
  25.                 POP ES          PUSH BX
  26.                 NEXT            END-CODE
  27.  
  28. CODE DONE?      ( n -- f )
  29.                 POP AX
  30.                 CMP AX, STATE
  31.             0<> IF
  32.                         MOV END? # 0 WORD
  33.                         MOV AX, # -1
  34.                         1PUSH
  35.                 THEN
  36.                 PUSH END?
  37.                 MOV END? # 0 WORD
  38.                 NEXT
  39.                 END-CODE
  40.  
  41. \ : DONE?         ( n -- f )
  42. \                 STATE @ <>   END? @ OR   END? OFF   ;
  43.  
  44. HEX
  45.  
  46. : CNHASH        ( CFA-YA )
  47.                 0FE00 AND FLIP ;  DECIMAL
  48.  
  49. : CNSRCH        ( CFA YA MAXYA - NFA failf )
  50.                 SWAP 2+ 2+
  51.                 BEGIN 2DUP U> WHILE ( cfa mxy nfa )
  52.                         DUP YC@ 31 AND + 1+ DUP Y@
  53.                         3 PICK =
  54.                         IF -ROT 2DROP 1- -1 TRAVERSE FALSE EXIT THEN
  55.             6 + REPEAT   2DROP TRUE ;
  56.  
  57. : N>LINK        2-   ;
  58. : L>NAME        2+   ;
  59. : BODY>         3 -  ;
  60.  
  61. : NAME>         1 TRAVERSE   1+ Y@  ;
  62. : LINK>         L>NAME   NAME>   ;
  63. : >BODY         3 +  ;
  64.  
  65. HERE-Y 4 +     \ Step from view field to name field
  66.  
  67. : NO-NAME ;
  68.  
  69. : >NAME         ( cfa - nfa )
  70.                 DUP CNHASH DUP Y@ SWAP
  71.                 2+ Y@ ( cfa sya mxya ) CNSRCH
  72.                 IF      DROP (LIT) [ ROT ,-X ] THEN    ;
  73.  
  74. : >LINK         >NAME   N>LINK   ;
  75. : >VIEW         >LINK   2-   ;
  76. : VIEW>         2+   LINK>   ;
  77.  
  78. CODE HASH       ( str-addr voc-ptr -- thread )
  79.                 POP CX          POP BX
  80.                 MOV AL, 0 [BX]  ADD AL, 1 [BX]
  81.                 AND AX, # #THREADS 1-
  82.                 SHL AX, # 1     ADD AX, CX
  83.                 1PUSH           END-CODE
  84.  
  85. CODE (FIND)     ( here alf -- cfa flag | here false )
  86.                 POP BX
  87.                 OR BX, BX
  88.              0= IF
  89.                         SUB AX, AX
  90.                         1PUSH
  91.                 THEN
  92.                 POP CX
  93.                 PUSH ES
  94.                 MOV ES, YSEG
  95.                 MOV DI, CX
  96.             BEGIN
  97.                 MOV ES: AX, 2 [BX]
  98.                 XOR AX, 0 [DI]
  99.                 AND AX, # ( 63 ) $7F3F
  100.              0= IF
  101.                         MOV DX, BX
  102.                         ADD BX, # 2
  103.                         BEGIN
  104.                                 INC BX  INC DI
  105.                                 MOV ES: AL, 0 [BX]
  106.                                 XOR AL, 0 [DI]
  107.                     0<> UNTIL
  108.                         AND AL, # 127
  109.                      0= IF
  110.                                 MOV ES: CX, 1 [BX]      \ pick up CFA
  111.                                 MOV BX, DX
  112.                                 MOV ES: AL, 2 [BX]
  113.                                 AND AL, # 64
  114.                                 0<> IF
  115.                                     MOV AX, # 1
  116.                                 ELSE
  117.                                     MOV AX, # -1
  118.                                 THEN
  119.                                 POP ES
  120.                                 PUSH CX
  121.                                 1PUSH
  122.                         THEN
  123.                         MOV BX, DX
  124.                         MOV DI, CX
  125.                 THEN
  126.                 MOV ES: BX, 0 [BX]
  127.                 OR BX, BX
  128.         0= UNTIL
  129.                 POP ES
  130.                 PUSH CX
  131.                 SUB AX, AX
  132.                 1PUSH           END-CODE
  133.  
  134. CODE DROP.CONTEXT.I2*+@DUP   ( A1 --- N1 )
  135.                 POP AX
  136.                 MOV AX, 0 [RP]
  137.                 ADD AX, 2 [RP]
  138.                 SHL AX, # 1
  139.                 MOV BX, # CONTEXT
  140.                 ADD BX, AX
  141.                 PUSH 0 [BX]
  142.                 PUSH 0 [BX]
  143.                 NEXT
  144.                 END-CODE
  145.  
  146.                                 \ DUP PRIOR @ OVER PRIOR ! =
  147. CODE PRIOR.CHECK ( N1 --- N1 F1 )
  148.                 POP AX
  149.                 PUSH AX
  150.                 MOV BX, PRIOR
  151.                 MOV PRIOR AX
  152.                 CMP BX, AX
  153.             0<> IF
  154.                         MOV AX, # FALSE
  155.                         1PUSH
  156.                 THEN
  157.                 MOV AX, # TRUE
  158.                 1PUSH
  159.                 END-CODE
  160.  
  161. CODE OVER.SWAP.HASH.@
  162.                 POP AX
  163.                 POP BX
  164.                 PUSH BX
  165.                 MOV BX, 0 [BX]
  166.                 ADD BL, BH
  167.                 AND BX, # #THREADS 1-
  168.                 SHL BX, # 1
  169.                 ADD BX, AX
  170.                 MOV AX, 0 [BX]
  171.                 1PUSH           END-CODE
  172.  
  173. : FIND          ( addr -- cfa flag | addr false )
  174.                 DUP C@
  175.                 IF      PRIOR OFF   FALSE   #VOCS 0
  176.                         DO      DROP.CONTEXT.I2*+@DUP
  177.                                 IF      PRIOR.CHECK
  178.                                         IF      DROP FALSE
  179.                                         ELSE    OVER.SWAP.HASH.@ (FIND)
  180.                                                 DUP ?LEAVE
  181.                                         THEN
  182.                                 THEN
  183.                         LOOP
  184.                 ELSE    DROP END? ON  ['] NOOP 1
  185.                 THEN    ;
  186.  
  187. : DEFINED       ( -- here 0 | cfa [ -1 | 1 ] )
  188.                 BL WORD  ?UPPERCASE  FIND   ;
  189.  
  190. : STACKUNDER    ( --- )
  191.                 TRUE ABORT" Stack Underflow" ;
  192.  
  193. : STACKOVER     ( --- )
  194.                 TRUE ABORT" Stack Overflow" ;
  195.  
  196. : WARNOVER      ( --- )
  197.                 CR ."  Running out of CODE memory! " ;
  198.  
  199. CODE (?STACK)   ( --- )
  200.                 MOV CX, SP
  201.                 MOV BX, UP
  202.                 MOV BX, SP0 [BX]
  203.                 CMP BX, CX
  204.              U< IF
  205.                         MOV AX, # ' STACKUNDER
  206.                         JMP AX
  207.                 THEN
  208.                 MOV BX, UP
  209.                 MOV BX, DP [BX]
  210.                 ADD BX, # 80
  211.                 CMP CX, BX
  212.              U< IF
  213.                         MOV AX, # ' STACKOVER
  214.                         JMP AX
  215.                 THEN
  216.                 ADD BX, # 200
  217.                 CMP CX, BX
  218.              U< IF
  219.                         MOV AX, # ' WARNOVER
  220.                         JMP AX
  221.                 THEN
  222.                 NEXT            END-CODE
  223.  
  224. \ : (?STACK)      ( -- )
  225. \               SP@ SP0 @ OVER  U<   ABORT" Stack Underflow"
  226. \                   PAD   2DUP  U<   ABORT" Stack Overflow"
  227. \                         200 + U<
  228. \               IF      CR ."  Running out of CODE memory! "
  229. \               THEN    ;
  230.  
  231. DEFER ?STACK    ' (?STACK) IS ?STACK
  232.  
  233. : INTERP        ( -- )
  234.                 BEGIN   ?STACK  DEFINED
  235.                         IF     EXECUTE
  236.                         ELSE   NUMBER  DOUBLE? NOT IF  DROP  THEN
  237.                         THEN   FALSE DONE?
  238.                 UNTIL   ;
  239.  
  240. DEFER STATUS    ( -- )
  241.  
  242. DEFER INTERPRET ' INTERP IS INTERPRET
  243.  
  244. : PRINT         ( --- ) PRINTING ON INTERPRET PRINTING OFF ;
  245.  
  246. : ALLOT         ( n -- )      DP +!   ;
  247.  
  248. CODE ,          ( N --- )
  249.                 MOV BX, UP
  250.                 MOV AX, DP [BX]
  251.                 MOV CX, # 2
  252.                 ADD DP [BX], CX
  253.                 MOV BX, AX
  254.                 POP CX
  255.                 MOV 0 [BX], CX
  256.                 NEXT
  257.                 END-CODE
  258.  
  259. CODE C,         ( N --- )
  260.                 MOV BX, UP
  261.                 MOV AX, DP [BX]
  262.                 INC DP [BX] WORD
  263.                 MOV BX, AX
  264.                 POP CX
  265.                 MOV 0 [BX], CL
  266.                 NEXT
  267.                 END-CODE
  268.  
  269. : PARAGRAPH     ( OFFSET --- PARAGRAPH-INC ) 15 + U16/ ;
  270. : ALIGN         ( HERE 1 AND IF  BL C,  THEN )  ; IMMEDIATE
  271. : EVEN          ( DUP 1 AND + ) ;  IMMEDIATE
  272. : COMPILE       ( -- )   2R@SWAP R> 2+ >R @L X,   ;
  273. : CCOMPILE      ( -- )   2R@SWAP R> 2+ >R @L  ,   ;
  274. : IMMEDIATE     ( -- )   64 ( Precedence bit ) LAST @ YCSET  ;
  275. : LITERAL       ( n -- )  COMPILE (LIT) X, ; IMMEDIATE
  276. : DLITERAL      ( d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE
  277.  
  278. : ASCII         ( -- n )   BL WORD   1+ C@
  279.                 STATE @ IF   [COMPILE] LITERAL   THEN   ; IMMEDIATE
  280.  
  281. : CONTROL       ( -- n )   BL WORD   1+ C@  31 AND
  282.                 STATE @ IF   [COMPILE] LITERAL   THEN   ; IMMEDIATE
  283.  
  284. : CRASH         ( -- ) 2R@SWAP 2- @L >NAME CR .ID TRUE
  285.                 ABORT" <- is an Uninitialized execution vector."  ;
  286.  
  287. : ?MISSING      ( f -- )
  288.                 IF      'WORD COUNT TYPE
  289.                         TRUE ABORT"  <- huh?, I'm confused! "
  290.                 THEN    ;
  291.  
  292. : '             ( -- cfa )      DEFINED 0= ?MISSING   ;
  293.  
  294. : [']           ( -- )          ' [COMPILE] LITERAL   ; IMMEDIATE
  295. : [COMPILE]     ( -- )          ' X,   ; IMMEDIATE
  296.  
  297. VARIABLE  "BUF 80 ALLOT
  298.  
  299. : XEVEN         ( XDP --- XDP_EVEN ) DUP 1 AND + ;
  300.  
  301. : XALIGN        ( --- ) XHERE NIP 1 AND XDP +! ;
  302.  
  303. : X>"BUF        ( --- "BUF )
  304.                 2R>
  305.                 2R@SWAP 2DUP C@L 1+ DUP XEVEN R> + >R
  306.                         ?CS: "BUF ROT CMOVEL
  307.                 2>R "BUF ;
  308.  
  309. : (")           ( -- addr len )
  310.                 2R@SWAP @L COUNT R> 2+ >R ;
  311.  
  312. : (X")           ( -- addr len )
  313.                 X>"BUF COUNT ;
  314.  
  315. : (.")          ( -- )
  316.                 2R@SWAP 2DUP C@L >R 1+ R@ EXTYPE R> 1+ XEVEN R> + >R ;
  317.  
  318. : ,"            ( --- )
  319.                 ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ;
  320.  
  321. : X,"           ( -- )
  322.                 ASCII " PARSE 'WORD PLACE
  323.                 ?CS: 'WORD DUP C@ 1+ >R XHERE R@ CMOVEL
  324.                 R> XEVEN XDP +! ;
  325.  
  326. : ."            ( -- )          COMPILE (.") X,"   ;   IMMEDIATE
  327.  
  328. : "             ( -- )          COMPILE (")  HERE X, ,"   ;   IMMEDIATE
  329.  
  330. : ""            ( -- )          COMPILE (X")  X,"   ;   IMMEDIATE
  331.  
  332. : ">$           ( A1 -- A2 )    DROP 1- ;
  333.  
  334. VARIABLE FENCE
  335.  
  336. : TRIM          ( faddr voc-addr -- )
  337.                 #THREADS 0
  338.                 DO      2DUP @ BEGIN   2DUP U> NOT WHILE Y@ REPEAT
  339.                         NIP OVER ! 2+
  340.                 LOOP    2DROP   ;
  341.  
  342. : (FRGET)       ( code-addr view-addr -- )
  343.                 DUP FENCE @ U< ABORT" Below fence"  ( ca va )
  344.                 OVER VOC-LINK @ BEGIN   2DUP U< WHILE   @ REPEAT
  345.                 DUP VOC-LINK !  ( ca va ca pt ) NIP
  346.                 BEGIN   DUP WHILE   2DUP #THREADS 2* - TRIM   @   REPEAT
  347.                 DROP    YDP !
  348.                 DUP 1+ @ OVER >BODY +
  349.                 (LIT)   TRIM DUP 1+ @ SWAP >BODY + =    \ If it's a : def
  350.                 IF      DUP >BODY @ XSEG @ + XDPSEG !   \ Set back XHERE too!
  351.                         XDP OFF
  352.                 THEN    DP !  ;
  353.  
  354. DEFER WHERE
  355. DEFER ?ERROR
  356.  
  357. : (?ERROR)      ( adr len f -- )
  358.                 IF      2>R SP0 @ SP!   PRINTING OFF
  359.                         2R> SPACE TYPE SPACE   QUIT
  360.                 ELSE    2DROP  THEN  ;
  361.  
  362. : (ABORT")      ( f -- )
  363.                 X>"BUF COUNT ROT ?ERROR ;
  364.  
  365. : ABORT"        ( -- )   COMPILE (ABORT") X," ;   IMMEDIATE
  366. : ABORT         ( -- )   TRUE ABORT" "  ;
  367.  
  368. : FORGET        ( -- )
  369.                 BL WORD ?UPPERCASE DUP CURRENT @ HASH @
  370.                 (FIND) 0= ?MISSING DUP >VIEW (FRGET) ;
  371.  
  372. : ?CONDITION    ( f -- )        NOT ABORT" Conditionals Wrong"   ;
  373.  
  374. : >MARK         ( -- addr )     XHERE NIP 0 X,   ;
  375. : >RESOLVE      ( addr -- )     XHERE -ROT SWAP !L   ;
  376. : <MARK         ( -- addr )     XHERE NIP ;
  377. : <RESOLVE      ( addr -- )     X, ;
  378.  
  379. : ?>MARK        ( -- f addr )   TRUE >MARK   ;
  380. : ?>RESOLVE     ( f addr -- )   SWAP ?CONDITION >RESOLVE  ;
  381. : ?<MARK        ( -- f addr )   TRUE   <MARK   ;
  382. : ?<RESOLVE     ( f addr -- )   SWAP ?CONDITION <RESOLVE  ;
  383.  
  384. : LEAVE         COMPILE (LEAVE)                                 ; IMMEDIATE
  385. : ?LEAVE        COMPILE (?LEAVE)                                ; IMMEDIATE
  386. : BEGIN         COMPILE DOBEGIN ?<MARK                          ; IMMEDIATE
  387. : THEN          COMPILE DOTHEN ?>RESOLVE                        ; IMMEDIATE
  388. : DO            COMPILE (DO)   ?>MARK                           ; IMMEDIATE
  389. : ?DO           COMPILE (?DO)  ?>MARK                           ; IMMEDIATE
  390. : LOOP          COMPILE (LOOP)  2DUP 2+ ?<RESOLVE ?>RESOLVE     ; IMMEDIATE
  391. : +LOOP         COMPILE (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE     ; IMMEDIATE
  392. : UNTIL         COMPILE ?UNTIL     ?<RESOLVE                    ; IMMEDIATE
  393. : AGAIN         COMPILE  DOAGAIN   ?<RESOLVE                    ; IMMEDIATE
  394. : REPEAT        2SWAP COMPILE DOREPEAT ?<RESOLVE ?>RESOLVE      ; IMMEDIATE
  395. : IF            COMPILE  ?BRANCH  ?>MARK                        ; IMMEDIATE
  396. : ELSE          COMPILE  BRANCH ?>MARK  2SWAP ?>RESOLVE         ; IMMEDIATE
  397. : WHILE         COMPILE ?WHILE ?>MARK                           ; IMMEDIATE
  398.  
  399. : ,VIEW         ( -- )  LOADLINE @ Y, ;
  400.  
  401. : "HEADER       ( STR --- )
  402.               #HEADSEGS YHERE U16/          6 + < ABORT" Out of HEAD memory!"
  403.               #LISTSEGS XHERE DROP XSEG @ - 6 + < ABORT" Out of LIST memory!"
  404.                 WARNING @  IF DUP FIND NIP IF
  405.                 DUP  CR  COUNT TYPE ."  isn't unique " THEN  THEN ( str )
  406.                 ALIGN  YHERE 2- Y@ CNHASH  HERE CNHASH  <>
  407.                 IF      YHERE HERE CNHASH DUP Y@ ROT MIN SWAP
  408.                         Y! ( >NAME hash entry )
  409.                 THEN    ,VIEW
  410.                 YHERE OVER CURRENT @ HASH DUP @  Y,  ( link  ) ! ( current )
  411.                 YHERE LAST ! ( remember nfa )
  412.                 YHERE ?CS: ROT  DUP C@  WIDTH @  MIN 1+ >R  ( yh cs str )
  413.                 YHERE YS: R@ CMOVEL ( copy str ) R> YDP +! ALIGN ( nam )
  414.                 128 SWAP YCSET   128 YHERE 1- YCSET   ( delimiter Bits )
  415.                 HERE Y, ( CFA in header )
  416.                 YHERE HERE CNHASH 2+ Y! ( valid stopper in next n hash entry)
  417.                 ;
  418.  
  419. : ,CALL         232 C, 0 HERE 2+ - , ;        \ Compiles addr 0000 !!!!
  420. : ,JUMP         233 C, 0 HERE 2+ - , ;
  421.  
  422. : <HEADER>      ( | name --- )
  423.                 BL WORD ?UPPERCASE "HEADER ;
  424.  
  425. DEFER HEADER    ' <HEADER> IS HEADER
  426.  
  427. : CREATE        ( | name -- )  HEADER ,CALL ;USES >NEXT ,-X
  428.  
  429. : !CSP          ( -- )  SP@ CSP !   ;
  430.  
  431. : ?CSP          ( -- )  SP@ CSP @ <> ABORT" Stack Changed"   ;
  432.  
  433. : HIDE          ( -- )  LAST @ DUP N>LINK Y@ SWAP CURRENT @ YHASH ! ;
  434.  
  435. : REVEAL        ( -- )  LAST @ DUP N>LINK    SWAP CURRENT @ YHASH ! ;
  436.  
  437. : (;USES)       ( -- )
  438.                 2R> SWAP @L LAST @ NAME> DUP >R 3 + - R> 1+ ! ;
  439.  
  440. : (;CODE)       ( -- )
  441.                 2R> SWAP @L LAST @ NAME>
  442.                 DUP >R 232 ( CALL ) R@ C!       \ Make a CALL not JUMP
  443.                 3 + - R> 1+ !  ;
  444.  
  445. : DOES>         ( -- )
  446.                 COMPILE (;CODE) HERE X, 232 ( CALL ) C,
  447.                 [ [FORTH] ASSEMBLER DODOES META ] LITERAL
  448.                 HERE 2+ - , XHERE PARAGRAPH + DUP XDPSEG !
  449.                 XSEG @ - , XDP OFF ; IMMEDIATE
  450.  
  451. VOCABULARY ASSEMBLER
  452.  
  453. DEFER SETASSEM  \ Setup for assembly stuff to follow
  454.  
  455. ' NOOP IS SETASSEM
  456.  
  457. : [             ( -- )  STATE OFF   ;   IMMEDIATE
  458.  
  459. : ;USES         ( -- )  ?CSP   COMPILE  (;USES)
  460.                 [COMPILE] [   REVEAL   ASSEMBLER   ; IMMEDIATE
  461.  
  462. : ;CODE         ( -- )  ?CSP   COMPILE  (;CODE) HERE X,
  463.                 [COMPILE] [   REVEAL   SETASSEM ; IMMEDIATE
  464.  
  465. : (])           ( -- )
  466.                 STATE ON
  467.         BEGIN   ?STACK   DEFINED DUP
  468.                 IF      0> IF    EXECUTE   ELSE   X,   THEN
  469.                 ELSE   DROP   NUMBER  DOUBLE?
  470.                         IF          [COMPILE] DLITERAL
  471.                         ELSE DROP   [COMPILE] LITERAL   THEN
  472.                 THEN   TRUE DONE?
  473.         UNTIL   ;
  474.  
  475. DEFER ]         ' (]) IS ]
  476.  
  477. : MAKEDUMMY     ( NAME --- )
  478.                 HEADER ,JUMP
  479.                 XHERE PARAGRAPH +       \ absolute paragraph of new def
  480.                 DUP XDPSEG !            \ set new XHERE segment
  481.                 XSEG @ - ,              \ compile relative paragraph of def
  482.                 XDP OFF
  483.                 COMPILE UNNEST
  484.                 ;USES  NEST ,-X
  485.  
  486. : ANEW          ( NAME --- )
  487.                 >IN @ >R DEFINED NIP  R@ >IN !
  488.                 IF      FORGET
  489.                 THEN    R> >IN !  MAKEDUMMY   ;
  490.                                                         \ Add if needed
  491. : :             ( -- )
  492.                 !CSP   CURRENT @ CONTEXT !
  493.                 HEADER ,JUMP
  494.                 XHERE PARAGRAPH +
  495.                 DUP XDPSEG !
  496.                 XSEG @ - ,
  497.                 XDP OFF
  498.                 HIDE    ]
  499.                 ;USES   NEST ,-X
  500.  
  501. : ;             ( -- )
  502.                 STATE @ 0= ABORT" Not Compiling!"
  503.                 ?CSP   COMPILE UNNEST   REVEAL   [COMPILE] [  ; IMMEDIATE
  504.  
  505. : RECURSIVE     ( -- )  REVEAL ;   IMMEDIATE
  506.  
  507. : CONSTANT      ( n -- ) CREATE ,   ;USES DOCONSTANT ,-X
  508.  
  509. : VARIABLE      ( -- )   CREATE 0 ,   ;USES >NEXT ,-X
  510.                                         \ not really needed, but pretty.
  511.  
  512. : DEFER         ( -- )
  513.                 CREATE   ['] CRASH ,  ;USES   DODEFER  ,-X
  514.  
  515. DODEFER RESOLVES <DEFER>
  516.  
  517. : VOCABULARY    ( -- )  CREATE   #THREADS 0 DO   0 ,  LOOP
  518.                         HERE  VOC-LINK @ ,  VOC-LINK !
  519.                         DOES> CONTEXT !  ;
  520.  
  521.  RESOLVES <VOCABULARY>
  522.  
  523. : DEFINITIONS   ( -- ) CONTEXT @ CURRENT !   ;
  524.  
  525. : 2CONSTANT     CREATE   , ,    ( d# -- )
  526.                 DOES> 2@   ;    ( -- d# )   DROP
  527.  
  528. : 2VARIABLE     0 0 2CONSTANT   ( -- )
  529.                 DOES> ;         ( -- addr )   DROP
  530.  
  531. : <RUN>         ( -- )
  532.         STATE @ IF      ]
  533.                         STATE @ NOT
  534.                         IF   INTERPRET   THEN
  535.                 ELSE    INTERPRET   THEN   ;
  536.  
  537. DEFER RUN       ' <RUN> IS RUN
  538.  
  539.  
  540.